;;;; Befune-93 interpreter.

;;; Allowed program dimensions.
(defconstant program-columns 80)
(defconstant program-rows 25)
;;; Program contained as a list of strings.
(defparameter *program* (make-array (list program-rows program-columns) :initial-element #\Space))
;;; Location of current program counter (PC).
(defparameter *pc* (vector 0 0))
;;; Direction of execution. Possible
;;; values are: #\>, #\<, #\^, #\v.
(defparameter *current-direction* #\>)
;;; Stack
(defparameter *st* '())
;;; String mode
(defparameter *string-mode* nil)

;;; Load Befunge program.
(defun load-program ()
  (let ((in (open (elt *args* 0) :if-does-not-exist nil))
	(lines-read 0))
    (if in
	(do ((line (read-line in nil) (read-line in nil))
	     (row 0 (+ row 1)))
	    ((or (not line)
		 (> row (- program-rows 1))))
	  (do ((col 0 (+ col 1))
	       (row lines-read))
	      ((or (> col (- (length line) 1))
		    (> col (- program-columns 1))))
	    (setf (aref *program* row col) (char line col)))
	  (incf lines-read)))))

;;; Control the motion of the PC.
;;; Wraps around if PC reaches an end.
(defun move-pc-up ()
  (if (= (svref *pc* 0) 0)
      (incf (svref *pc* 0) (- program-rows 1))
      (decf (svref *pc* 0))))

(defun move-pc-down ()
  (if (= (svref *pc* 0)
	 (- program-rows 1))
      (decf (svref *pc* 0) (- program-rows 1))
      (incf (svref *pc* 0))))

(defun move-pc-left ()
  (if (= (svref *pc* 1) 0)
      (incf (svref *pc* 1) (- program-columns 1))
      (decf (svref *pc* 1))))

(defun move-pc-right ()
  (if (= (svref *pc* 1)
	 (- program-columns 1))
      (decf (svref *pc* 1) (- program-columns 1))
      (incf (svref *pc* 1))))

(defun move-pc-default ()
    (cond ((char= *current-direction* #\>) (move-pc-right))
	((char= *current-direction* #\<) (move-pc-left))
	((char= *current-direction* #\^) (move-pc-up))
	((char= *current-direction* #\v) (move-pc-down))))

;;; Controls which direction the PC will be moving.
(defun set-direction-left ()
  (setf *current-direction* #\<))

(defun set-direction-right ()
  (setf *current-direction* #\>))

(defun set-direction-up ()
  (setf *current-direction* #\^))

(defun set-direction-down ()
  (setf *current-direction* #\v))

;;; Current PC.
(defun current-pc-value ()
  (aref *program* (svref *pc* 0) (svref *pc* 1)))

;;; Main program loop. User interacts with
;;; the interpreter by typing commands.
;;; Accepted commands are: quit, next, and
;;; print-state.
(defun init ()
  (load-program)
  (format t "~a" ">> ")
  (do ((command (read-line) (read-line)))
      ((string= command "quit"))
    (if (string= command "next")
	(next)
	(if (string= command "print-state")
	    (print-state)))
    (format t "~a" ">> ")))

;;; Non interactive main loop. Executes until
;;; @ is reached in the Befunge code.
(defun init-inf ()
  (load-program)
  (do () (()) (next)))
  
;;; Process command at the PC.
(defun next ()
  ;; stringmode checking has to be at the top.
  (cond ((and *string-mode*
	      (not (char= (current-pc-value) #\"))) (push (char-code (current-pc-value)) *st*))
	((char= (current-pc-value) #\0) (push 0 *st*))
	((char= (current-pc-value) #\1) (push 1 *st*))
	((char= (current-pc-value) #\2) (push 2 *st*))
	((char= (current-pc-value) #\3) (push 3 *st*))
	((char= (current-pc-value) #\4) (push 4 *st*))
	((char= (current-pc-value) #\5) (push 5 *st*))
	((char= (current-pc-value) #\6) (push 6 *st*))
	((char= (current-pc-value) #\7) (push 7 *st*))
	((char= (current-pc-value) #\8) (push 8 *st*))
	((char= (current-pc-value) #\9) (push 9 *st*))
	((char= (current-pc-value) #\>) (set-direction-right))
	((char= (current-pc-value) #\<) (set-direction-left))
	((char= (current-pc-value) #\^) (set-direction-up))
	((char= (current-pc-value) #\v) (set-direction-down))
	((char= (current-pc-value) #\+) (op-add))
	((char= (current-pc-value) #\-) (op-sub))
	((char= (current-pc-value) #\*) (op-mul))
	((char= (current-pc-value) #\/) (op-div))
	((char= (current-pc-value) #\%) (op-mod))
	((char= (current-pc-value) #\!) (op-not))
	((char= (current-pc-value) #\`) (op-greater))
	((char= (current-pc-value) #\?) (op-random))
	((char= (current-pc-value) #\_) (op-if-horizontal))
	((char= (current-pc-value) #\|) (op-if-vertical))
	((char= (current-pc-value) #\") (op-string-mode-toggle))
	((char= (current-pc-value) #\:) (op-dup))
	((char= (current-pc-value) #\\) (op-swap))
	((char= (current-pc-value) #\$) (op-pop-no-output))
	((char= (current-pc-value) #\.) (op-pop-as-integer))
	((char= (current-pc-value) #\,) (op-pop-ascii))
	((char= (current-pc-value) #\#) (op-bridge))
	((char= (current-pc-value) #\g) (op-get))
	((char= (current-pc-value) #\p) (op-put))
	((char= (current-pc-value) #\&) (op-input-value))
	((char= (current-pc-value) #\~) (op-input-character))
	((char= (current-pc-value) #\@) (quit)))
  (move-pc-default))

(defun print-state ()
  (format t "~a~%" "Stack")
  (format t "~a~%" *st*)
  (format t "~a:~a~%" "Current PC Value" (current-pc-value))
  (format t "~a~%" "Direction")
  (format t "~a~%" *current-direction*)
  (format t "~a~%" "String mode")
  (format t "~a~%" *string-mode*)
  (format t "~a~%" "*pc*")
  (format t "~a~%" *pc*)
  (format t "~%" ""))
    

(defun pop-stack ()
  (let ((value (pop *st*)))
    (if (numberp value)
	value
	0)))

(defun push-stack(value)
  (push value *st*))

;;; Ops.
(defun op-add ()
  (let ((value2 (pop-stack))
	(value1 (pop-stack)))
    (push-stack (+ value1 value2))))
  
(defun op-sub ()
  (let ((value2 (pop-stack))
	(value1 (pop-stack)))
    (push-stack (- value1 value2))))

(defun op-div ()
  (let ((value2 (pop-stack))
	(value1 (pop-stack)))
    (if (> value2 0)
	(push-stack (floor value1 value2))
	(error-and-quit "OP DIV division my zero"))))

(defun op-mul ()
  (let ((value2 (pop-stack))
	(value1 (pop-stack)))
    (push-stack (* value1 value2))))

(defun op-mod ()
  (let ((value2 (pop-stack))
	(value1 (pop-stack)))
    (push-stack (mod value1 value2))))

(defun op-not ()
  (let ((value (pop-stack)))
    (if (zerop value)
	(push 1 *st*)
	(push 0 *st*))))

(defun op-greater ()
  (let ((value2 (pop-stack))
	(value1 (pop-stack)))
    (if (> value1 value2)
	(push-stack 1)
	(push-stack 0))))

(defun op-random ()
  (let ((num (mod (get-internal-real-time) 4))) ; good enough for Befunge :)
    (cond ((= num 0) (set-direction-left))
	  ((= num 1) (set-direction-right))
	  ((= num 2) (set-direction-up))
	  ((= num 3) (set-direction-down)))))
  
(defun op-if-horizontal ()
  (let ((value (pop *st*)))
    (if (or (not value) ;short-circuiting
	    (zerop value))
	(set-direction-right)
	(set-direction-left))))

(defun op-if-vertical ()
  (let ((value (pop *st*)))
    (if (or (not value) ;short-circuiting
	    (zerop value))
	(set-direction-down)
	(set-direction-up))))

(defun op-string-mode-toggle ()
  (setf *string-mode* (not *string-mode*)))

(defun op-dup ()
  (let ((value (pop-stack)))
    (push-stack value)
    (push-stack value)))
      
(defun op-swap ()
  (let ((value2 (pop-stack))
	(value1 (pop-stack)))
    (push-stack value2)
    (push-stack value1)))

(defun op-pop-no-output ()
  (pop-stack))

(defun op-pop-as-integer ()
  (format t "~a " (pop-stack)))

(defun op-pop-ascii ()
  (format t "~a" (code-char (pop-stack))))

(defun op-bridge ()
  (move-pc-default))

(defun op-get ()
  (let ((y (pop-stack))
	(x (pop-stack)))
    (if (and (< y program-rows)
	     (< x program-columns)
	     (>= y 0)
	     (>= x 0))
	(push-stack (char-code (aref *program* y x)))
	(error-and-quit "OP GET out of bound"))))

(defun op-put ()
  (let ((y (pop-stack))
	(x (pop-stack))
	(value (pop-stack)))
    (if (and (>= y 0)
	     (>= x 0))
	(if (code-char value)
	    (setf (aref *program* y x) (code-char value))
	    (error-and-quit "OP PUT not a valid character"))
	(error-and-quit "OP PUT out of bound"))))

(defun op-input-value ()
  (let ((value (read-line *standard-input*)))
    (push-stack (parse-integer value))))

(defun op-input-character ()
  (let ((value (read-line *standard-input*)))
    (push-stack (char-code (char value 0)))))

(defun error-and-quit (msg)
  (format t "~a~%" msg)
  (quit))

(init-inf)